home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue24 / menus / ODMENUU.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1997-07-16  |  5.2 KB  |  168 lines
  1. unit ODMenuU;
  2.  
  3. interface
  4.  
  5. uses
  6.   SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  7.   Forms, Dialogs, Menus, StdCtrls;
  8.  
  9. type
  10.   TForm1 = class(TForm)
  11.     MainMenu1: TMainMenu;
  12.     Menu1: TMenuItem;
  13.     MenuItem1: TMenuItem;
  14.     MenuItem2: TMenuItem;
  15.     BmpDlg: TOpenDialog;
  16.     Button1: TButton;
  17.     HelpItem1: TMenuItem;
  18.     About1: TMenuItem;
  19.     HowtoUseHelp1: TMenuItem;
  20.     SearchforHelpOn1: TMenuItem;
  21.     Contents1: TMenuItem;
  22.     procedure FormCreate(Sender: TObject);
  23.     procedure FormDestroy(Sender: TObject);
  24.     procedure Button1Click(Sender: TObject);
  25.     procedure MenuItem1Click(Sender: TObject);
  26.     procedure MenuItem2Click(Sender: TObject);
  27.     procedure MenuItem3Click(Sender: TObject);
  28.   private
  29.     { Private declarations }
  30.   public
  31.     { Public declarations }
  32.     Bmp: TBitmap;
  33.     BmpFileName: String;
  34.     procedure SetupMenus(const BmpName: String);
  35.     procedure WMMeasureItem(var Msg: TWMMeasureItem); message wm_MeasureItem;
  36.     procedure WMDrawItem(var Msg: TWMDrawItem); message wm_DrawItem;
  37.   end;
  38.  
  39. var
  40.   Form1: TForm1;
  41.  
  42. implementation
  43.  
  44. {$R *.DFM}
  45.  
  46. { Customise bitmaps at run-time. First is a bitmap menu, }
  47. { the second is fully owner draw, bitmap + its file name }
  48. procedure TForm1.SetupMenus(const BmpName: String);
  49. begin
  50.   Bmp.LoadFromFile(BmpName);
  51.   BmpFileName := BmpName;
  52.   { First menu item is set to be a bitmap }
  53.   ModifyMenu(Menu1.Handle, MenuItem1.Command,
  54.     mf_ByCommand or mf_Bitmap, MenuItem1.Command, PChar(Bmp.Handle));
  55.   { Second menu item is set to be an owner draw-menu }
  56.   { So refer to the wm_MeasureItem and wm_DrawItem }
  57.   { message handlers for the details }
  58.   ModifyMenu(Menu1.Handle, MenuItem2.Command,
  59.     mf_ByCommand or mf_OwnerDraw, MenuItem2.Command, PChar(Bmp));
  60.   DrawMenuBar(Handle);
  61. end;
  62.  
  63. procedure TForm1.FormCreate(Sender: TObject);
  64. begin
  65.   Bmp := TBitmap.Create;
  66.   { Move Help menu over to the right }
  67.   { Windows 95/NT 4 apps support doing it this way ... }
  68.   {$ifndef AlternativeWay}
  69.   ModifyMenu(MainMenu1.Handle, 1, mf_ByPosition or mf_Popup or mf_Help,
  70.     HelpItem1.Handle, '&Help');
  71.   {$else}
  72.   { ... only Win 3.1x supports this }
  73.   HelpItem1.Caption := #8 + HelpItem1.Caption;
  74.   {$endif}
  75.   { Start off with some bitmap }
  76.   SetupMenus('c:\delphi\images\splash\16color\athena.bmp');
  77. end;
  78.  
  79. procedure TForm1.FormDestroy(Sender: TObject);
  80. begin
  81.   Bmp.Free;
  82. end;
  83.  
  84. procedure TForm1.WMMeasureItem(var Msg: TWMMeasureItem);
  85. begin
  86.   with Msg, MeasureItemStruct^ do
  87.     if (IDCtl = 0) and (CtlType = odt_Menu) and
  88.        (ItemID = MenuItem2.Command) then
  89.       with TBitmap(ItemData), Canvas do
  90.       begin
  91.         { Width is bitmap width + text width }
  92.         ItemWidth := Width + TextWidth(BmpFileName);
  93.         { Height is Max(bitmap width, text width) }
  94.         if Height > TextHeight(BmpFileName) then
  95.           ItemHeight := Height
  96.         else
  97.           ItemHeight := TextHeight(BmpFileName);
  98.         { Yes, we dealt with this message, all right? }
  99.         LongBool(Result) := True;
  100.       end;
  101. end;
  102.  
  103. procedure TForm1.WMDrawItem(var Msg: TWMDrawItem);
  104. const
  105.   Colors: array[False..True] of TColor = (clMenu, clHighlight);
  106.   TextColors: array[False..True] of TColor = (clMenuText, clHighlightText);
  107.   CopyModes: array[False..True] of TColor = (cmSrcCopy, cmNotSrcCopy);
  108. var
  109.   Rect: TRect;
  110.   SourceBmp: TBitmap;
  111. begin
  112.   with Msg, DrawItemStruct^ do
  113.     if (Ctl = 0) and (CtlType = odt_Menu) and
  114.        (ItemID = MenuItem2.Command) and (HWndItem = Menu1.Handle) then
  115.       with TCanvas.Create do
  116.         try
  117.           SourceBmp := TBitmap(ItemData);
  118.           { Yes, we dealt with this message, all right? }
  119.           LongBool(Result) := True;
  120.           { Map TCanvas over menu DC }
  121.           Handle := hDC;
  122.           { Fill in background with appropriate colour }
  123.           Brush.Color := Colors[ItemState and ods_Selected <> 0];
  124.           FillRect(RCItem);
  125.           { Centre bitmap vertically, in case shorter than the text }
  126.           Rect := Bounds(RCItem.Left,
  127.             (RCItem.Top + RCItem.Bottom - Bmp.Height) div 2,
  128.             SourceBmp.Width, SourceBmp.Height);
  129.           { Draw bitmap, normal or inverted as necessary }
  130.           CopyMode := CopyModes[ItemState and ods_Selected <> 0];
  131.           CopyRect(Rect, SourceBmp.Canvas, Classes.Rect(0, 0, SourceBmp.Width, SourceBmp.Height));
  132.           { Set up same font as menus use }
  133.           Font.Size := 8;
  134.           Font.Color := TextColors[ItemState and ods_Selected <> 0];
  135.           { Centre text vertically, in case shorter than the bitmap }
  136.           TextOut(RCItem.Left + SourceBmp.Width,
  137.             (RCItem.Top + RCItem.Bottom - TextHeight(BmpFileName)) div 2,
  138.             BmpFileName);
  139.         finally
  140.           Free
  141.         end;
  142. end;
  143.  
  144. procedure TForm1.Button1Click(Sender: TObject);
  145. begin
  146.   { Button allows menus to be dynamically }
  147.   { changed by picking a new bitmap }
  148.   if BmpDlg.Execute then
  149.     SetUpMenus(BmpDlg.FileName);
  150. end;
  151.  
  152. procedure TForm1.MenuItem1Click(Sender: TObject);
  153. begin
  154.   ShowMessage('First menu item');
  155. end;
  156.  
  157. procedure TForm1.MenuItem2Click(Sender: TObject);
  158. begin
  159.   ShowMessage('Second menu item');
  160. end;
  161.  
  162. procedure TForm1.MenuItem3Click(Sender: TObject);
  163. begin
  164.   ShowMessage('Third menu item');
  165. end;
  166.  
  167. end.
  168.